home *** CD-ROM | disk | FTP | other *** search
/ The PC-SIG Library 10 / The PC-Sig Library - Shareware for the IBM PC and Compatibles (PC-SIG)(Tenth Edition Disks 1-2804)(1991).iso / PC_SIGCD / 09 / 3 / DISK0932.ZIP / SOURCE.EXE / arc / LABCOAT.PAS < prev    next >
Pascal/Delphi Source File  |  1991-03-31  |  61KB  |  1,947 lines
  1.              { A Laboratory Management & Analysis Program }
  2.               {                  by                     }
  3.               { Douglas Standing & Gen. Max VonBirdface }
  4.  
  5.                           { VERSION 4.0 }
  6.  
  7.                         { Copyright 1991 }
  8.         { This version includes code to call QCHART.EXE out of the  }
  9.         { Statisitics routine in Labcoat.  The file Exec.com from   }
  10.         { Bela Lubkin, via TUG, is essential & much appreciated.    }
  11.         { If you wish to use or modify the code for Exec, contact   }
  12.         { me.  Unfortunately Birdface kicked the bucket 2/89,       }
  13.         { and he will not be able to help you.  He was a good bird. }
  14.  
  15.  
  16. PROGRAM LABCOAT;
  17.  
  18. VAR
  19.   QUIT : BOOLEAN;
  20.     CH : CHAR;
  21.     I,J: INTEGER;
  22.  
  23.  
  24. PROCEDURE CLEARLINES;              { Clears lines 23 & 24 for repeated entry }
  25.  
  26.     BEGIN
  27.         GOTOXY(1,23);
  28.         TEXTBACKGROUND(1);
  29.         CLREOL;
  30.         GOTOXY(1,24);
  31.         TEXTBACKGROUND(1);
  32.         CLREOL;
  33.     END;
  34.  
  35. PROCEDURE MAKEaLINE;                 { Screen drawer of lines }
  36.  
  37.    BEGIN
  38.      FOR I := 1 TO 80 DO
  39.        WRITE(CHR(205));
  40.        WRITELN;
  41.    END;
  42.  
  43. PROCEDURE MAKEaBORDER (VAR OUTFILE : TEXT);   { Makes lines on reports }
  44.    BEGIN
  45.      FOR I := 1 TO 80 DO
  46.        WRITE(LST,CHR(61));                  { best with EPSON char set }
  47.        WRITELN(LST);                         { IBM would be 205         }
  48.    END;
  49.  
  50. PROCEDURE SIGNON;                             { Initial Screen gizmo }
  51.  
  52.    BEGIN
  53.      GRAPHBACKGROUND(1);
  54.      TEXTBACKGROUND(1);
  55.      CLRSCR;
  56.      GOTOXY(15,8);
  57.      LOWVIDEO;
  58.      FOR I := 1 TO 50 DO
  59.        BEGIN
  60.          WRITE(CHR(205))
  61.        END;
  62.      GOTOXY(20,10);
  63.      HIGHVIDEO;
  64.      TEXTBACKGROUND(1);
  65.      TEXTCOLOR(4);
  66.      WRITELN('    LABORATORY DATA & COST ANALYSIS');
  67.      WRITELN('                                    by             ');
  68.      WRITELN('                       D. Standing  and M. VonBirdface');
  69.      WRITELN('                            v4.0 copyright 1991');
  70.      GOTOXY(15,14);
  71.      LOWVIDEO;
  72.      FOR J := 1 TO 50 DO
  73.        BEGIN
  74.          WRITE(CHR(205));
  75.        END;
  76.      DELAY(4500);
  77.      CLRSCR
  78.    END;
  79.  
  80. PROCEDURE EXPLAIN;                     { 2nd screen - blame it on Birdface }
  81.                                        { or remove the call from main code }
  82.   BEGIN                                { if it annoys you , or to speed up }
  83.     TEXTBACKGROUND(1); CLRSCR;GOTOXY(15,7);
  84.     WRITELN('The Name, Labcoat, & All Compiled Files Copyright 1991');
  85.     GOTOXY(15,10);
  86.     TEXTCOLOR(15);
  87.     WRITELN(' You will be asked for numerous inputs in this program.');
  88.     GOTOXY(15,12);
  89.     TEXTCOLOR(0);
  90.     WRITELN(' If you are interested in seeing a list of the variables,');
  91.     GOTOXY(15,13);
  92.     WRITELN('the opportunity to print them will come on the next screen.');
  93.     GOTOXY(15,15);
  94.     TEXTCOLOR(3);
  95.     WRITELN('  If you are pleased with the program or have comments,');
  96.     GOTOXY(15,16);
  97.     TEXTCOLOR(15);
  98.     WRITELN('     send comments AND CASHEWS to my co-author:');
  99.     GOTOXY(15,18);
  100.     TEXTCOLOR(4);
  101.     WRITELN('               General Max VonBirdface ');
  102.     GOTOXY(15,19);
  103.     WRITELN('         943 Aster Ct, Sunnyvale CA  94086');
  104.     GOTOXY(12,21);
  105.     TEXTCOLOR(3);
  106.     WRITELN('  (Birdface is the parrot who wrote most of the error traps)');
  107.     WRITELN;
  108.     TEXTCOLOR(0);
  109.     WRITE('                            Peck Any Key To Continue');
  110.     READ(KBD,CH);
  111.   END;
  112.  
  113. {###################### Main Test Cost Routine ##############################}
  114.  
  115. OVERLAY PROCEDURE GETIT;  { Note: The sole Overlay Procedure in this Program. }
  116.                           {       LIPID has many - Reason: Heap-Stack crashes }
  117.                           {       between Labcoat and Lipid at Lipid Call     }
  118.      TYPE
  119.         STRINGTYPE = STRING[50];
  120.  
  121.      VAR MAKER {manufacture name},
  122.          TESTNAME {kit name},
  123.          THISDATE {current date},
  124.          PLACENAME {clinic or lab name},
  125.          STABLELIFE {reagent reconstituted stability}              :STRINGTYPE;
  126.  
  127.          KITCOST {price/kit},
  128.          CONSUMPRICE {cost/test consumables},
  129.          CONSUMABLES {price/pkg of consumables},
  130.          COLLECTI {drawing/processing costs},
  131.          REFLAB {the competition price},
  132.          DEPRECYR {annual inst depreciation amount},
  133.          QC {cost/yr of survey spec for this test},
  134.          QCSPEC {qc/12},
  135.          YOURPRICE {tentative charge},
  136.          COSTTEST1 {kitcost/kittests},
  137.          PTREP {1 patient x replicate},
  138.          CONSUM {consumprice},
  139.          STANDARDSET {cost of separate stds},
  140.          STANDARDCOST {cost / run for sep stds },
  141.          CALIBCST {cost/pkg of calibrators},
  142.          CALIBCSTRN {cost per test run of calibration },
  143.          DRAW {collection},
  144.          SURVEY {qc/12/testpermonth},
  145.          DEPREC1 {depreciation costs/run},
  146.          INITIAL { the calculated cost / run setup },
  147.          PTS  { testcost for pts after initial },
  148.          PRIMECOST { cost per run of inst primes },
  149.          TESTCOST { initial + pts /  # patients per run },
  150.          TECHTIME { tech time in min. to do batch},
  151.          TECHDOLLARS { tech salary in $/Hr },
  152.          MAINTENENCE {service contract or yearly maint charges},
  153.          UPKEEP {cost/run for MAINTENENCE},
  154.          RUNKITMONTH { runs / kit / month },
  155.          RUNCONSUMMONTH {runs / pkg disposables / month },
  156.          LABOR { techtime x (techdollars/60 },
  157.          VT,CT,XT,FC,RT,DT,DE,CALR,CALC,  {see cost breakdown section}
  158.          BREAKEVEN,COSTBRKEVEN,PROFLOSS,REVBRKEVEN,  {deal w/ break-even}
  159.          TOTALCOST,TOTALSALES,UNITCOST,VARIABLECOST  {      "       }   : REAL;
  160.  
  161.          KITTESTS {number of tests/kit} ,
  162.          NUMCONTROLS {number of different control levels},
  163.          NUMSTANDARDS {number of standards/run},
  164.          BLANK {number of blanks/run} ,
  165.          REPLICATE {number of replicates of controls & pts/run},
  166.          NUMCONSUMTST {number of tests/pkg consumables},
  167.          TOTALANATST {max number/run for analyser},
  168.          STDSRUN {number of runs to use up purchased standards},
  169.          CALIBLIFE {# runs useful calibrator life},
  170.          CALFREQ {times/month calibrators used},
  171.          NUMCAL {number of calib tests each calibration},
  172.          TESTPERMONTH {expected number of this test/month},
  173.          SHELFLIFE {shelf life of kit reagents},
  174.          STANDARDLIFE {# of runs/std set},
  175.          MAXHEADROOM {est avg # pt spec/batch},
  176.          MAXBATCH {maximum batch # for analyser},
  177.          RUNSPERMONTH { expected # of runs per month },
  178.          PRIME { # tests reag used to prime inst. },
  179.          CURQUAN,ENDQTY,INCRQTY,STARTQTY, {for break-even}
  180.          SICKO { number of pts to be run }                          : INTEGER;
  181.  
  182. {************************** Input Section **********************************}
  183.  
  184.   BEGIN
  185.     GRAPHBACKGROUND(1);
  186.     TEXTBACKGROUND(1);
  187.     CLRSCR;
  188.     GOTOXY(1,5);
  189.     TEXTCOLOR(0);
  190.     MAKEaLINE;
  191.     GOTOXY(1,6);
  192.     TEXTCOLOR(4);
  193.     MAKEaLINE;
  194.     GOTOXY(1,7);
  195.     TEXTCOLOR(14);
  196.     MAKEaLINE;
  197.     GOTOXY(1,8);
  198.     TEXTCOLOR(2);
  199.     MAKEaLINE;
  200.     GOTOXY(1,9);
  201.     TEXTCOLOR(0);
  202.     MAKEaLINE;
  203.     GOTOXY(10,12);
  204.     TEXTCOLOR(0);
  205.     WRITELN('Please type in answers as requested, then press Enter Key.');
  206.     TEXTCOLOR(15);
  207.     WRITELN;
  208.     WRITE('                  DO NOT USE COMMAS OR DOLLAR SIGNS');
  209.     GOTOXY(1,23);
  210.     TEXTCOLOR(7);
  211.     WRITE('Enter the name of your Facility (( 50 Characters Max )).');
  212.     GOTOXY(1,24);
  213.     READ(PLACENAME);
  214.     CLEARLINES;
  215.     GOTOXY(1,23);
  216.     WRITE('Enter today''s date: ');
  217.     READ(THISDATE);
  218.     CLEARLINES;
  219.     GOTOXY(1,23);
  220.     WRITE('Enter the name of the test: ');
  221.     READLN(TESTNAME);
  222.     CLEARLINES;
  223.     GOTOXY(1,23);
  224.     WRITE('Name of the ',TESTNAME,' kit Manufacturer: ');
  225.     READLN(MAKER);
  226.     CLEARLINES;
  227.       KITCOST:= 0;KITTESTS:= 1;SHELFLIFE:=0;
  228.     GOTOXY(1,23);
  229.     WRITE('Enter the price / kit for ',MAKER,'''s kit: $ ');
  230.     READ(KITCOST);
  231.     CLEARLINES;
  232.     GOTOXY(1,23);
  233.     WRITE('Enter the number of tests in each ',MAKER,' kit: ');
  234.     READ(KITTESTS);
  235.     CLEARLINES;
  236.     GOTOXY(1,23);
  237.     WRITE
  238. ('Enter ',MAKER,'''s claimed avg. shelf life (months) for the reagents: ');
  239.     READ(SHELFLIFE);
  240.     CLEARLINES;
  241.     GOTOXY(1,23);
  242.     WRITE
  243.     ('Enter reconsituted stability of reagents (type hours or days): ');
  244.     READ(STABLELIFE);
  245.     CLEARLINES;
  246.     GOTOXY(1,23);
  247.       QC:= 0;NUMSTANDARDS:=0;STANDARDSET:= 0;STANDARDLIFE:= 1;
  248.     WRITE
  249.  ('If extra QC survey specimens are necessary, enter cost/yr (or `0''): $ ');
  250.     READ(QC);
  251.     CLEARLINES;
  252.     GOTOXY(1,23);
  253.     WRITE('Enter the number of standards each run: ');
  254.     READ(NUMSTANDARDS);
  255.       IF (NUMSTANDARDS > 0) THEN
  256.         BEGIN
  257.           CLEARLINES;
  258.           GOTOXY(1,23);
  259.           WRITE('Are the standards run in duplicate?  (Y/N): ');
  260.           READ(KBD,CH);
  261.             IF (CH = 'Y') OR (CH = 'y') THEN NUMSTANDARDS := NUMSTANDARDS * 2;
  262.           CLEARLINES;
  263.           GOTOXY(1,23);
  264.           WRITE('Are Standards purchased separately from the kit? (Y/N) : ');
  265.           READ(KBD,CH);
  266.             IF (CH='Y') OR (CH='y') THEN
  267.               BEGIN
  268.                 CLEARLINES; STANDARDSET:=0; STANDARDCOST:=0;
  269.                 GOTOXY(1,23);
  270.                 WRITE('Enter the cost of The Standards set:$  ');
  271.                 READ(STANDARDSET);
  272.                 CLEARLINES;
  273.                 GOTOXY(1,23);
  274.                 WRITE
  275.                 ('Enter the estimated # of runs obtained / standard set: ');
  276.                 READ(STANDARDLIFE);
  277.                 CLEARLINES;
  278.               END;
  279.           CLEARLINES;
  280.         END;
  281.   REPEAT
  282.       GOTOXY(1,23);
  283.       WRITE
  284.     ('Is calibration (as opposed to routine standards) required? (Y/N): ');
  285.       READ(KBD,CH);
  286.       CLEARLINES;
  287.       CALIBCST:=0;CALIBLIFE:=1;CALFREQ:=1;NUMCAL:=0;
  288.   UNTIL (CH = 'Y') OR (CH = 'y') OR (CH = 'N') OR (CH = 'n');
  289.     IF (CH='Y') OR (CH='y') THEN
  290.       BEGIN
  291.         CLEARLINES;
  292.         GOTOXY(1,23);
  293.         WRITE('What is the cost of calibrators? :$  ');
  294.         READ(CALIBCST);
  295.         CLEARLINES;
  296.         GOTOXY(1,23);
  297.         WRITE('How many months can calibrators be used? : ');
  298.         READ(CALIBLIFE);
  299.         CLEARLINES;
  300.         GOTOXY(1,23);
  301.         WRITE('How many times / year is calibration required? : ');
  302.         READ(CALFREQ);
  303.         CLEARLINES;
  304.         GOTOXY(1,23);
  305.         WRITE('How many calibrator tests are run each calibration? : ');
  306.         READ(NUMCAL);
  307.         CLEARLINES;
  308.       END;
  309.     CLEARLINES;
  310.       NUMCONTROLS:= 0;BLANK:= 1;REPLICATE:= 0;CONSUMABLES:= 0;
  311.     GOTOXY(1,23);
  312.     WRITE('Enter the number of different control levels / run: ');
  313.     READ(NUMCONTROLS);
  314.     CLEARLINES;
  315.     GOTOXY(1,23);
  316.     WRITE('Enter the number of blanks / run: ');
  317.     READ(BLANK);
  318.     CLEARLINES;
  319.       REPEAT
  320.         GOTOXY(1,23);
  321.         WRITE
  322.        ('Enter `2'' if you are running things in duplicate, or `1'' if not: ');
  323.         READ(REPLICATE);
  324.         CLEARLINES;
  325.       UNTIL (REPLICATE = 1) OR (REPLICATE = 2);
  326.   REPEAT
  327.     CLEARLINES;
  328.       CONSUMABLES:=0;NUMCONSUMTST:=1;CONSUMPRICE:=0;REFLAB:=0;MAINTENENCE:=0;
  329.     GOTOXY(1,23);
  330.     WRITELN
  331.     ('Does this test use consumables in the testing process? (Y/N): ');
  332.     READ(KBD,CH);
  333.   UNTIL (CH='Y') OR (CH='y') OR (CH='N') OR (CH='n');
  334.     IF (CH='Y') OR (CH='y') THEN
  335.     BEGIN
  336.       CLEARLINES;
  337.       GOTOXY(1,23);
  338.       WRITE
  339.     ('Enter price for a known quantity of consumables for ',MAKER,'''s test.');
  340.       WRITE('Pick the price for a package or case, etc: $ ');
  341.       READ(CONSUMABLES);
  342.       CLEARLINES;
  343.       GOTOXY(1,23);
  344.       WRITE('How many tests / package of those consumables?  ');
  345.       READ(NUMCONSUMTST);
  346.     END;
  347.     CLEARLINES;
  348.     GOTOXY(1,23);
  349.     WRITE
  350.     ('What is the estimated drawing cost (labor / supplies) / test: $  ');
  351.     READ(DRAW);
  352.     CLEARLINES;
  353.     GOTOXY(1,23);
  354.     WRITE('Enter the price your reference lab charges for ',TESTNAME,': $ ');
  355.     READ(REFLAB);
  356.     CLEARLINES;
  357.     GOTOXY(1,23);
  358.     TOTALANATST:=1;DEPRECYR:=0;PRIME:=1;PRIMECOST:=0;MAINTENENCE:=0;
  359.     TECHTIME:=0;TECHDOLLARS:=0;YOURPRICE:=0.001;STARTQTY:=0;
  360.     WRITE('Do you want to include instrumentation costs? (Y/N): ');
  361.     REPEAT
  362.     READ(KBD,CH);
  363.     UNTIL (CH='Y') OR (CH='y') OR (CH='N') OR (CH='n');
  364.     IF (CH=('Y')) OR (CH='y') THEN
  365.     BEGIN
  366.     GOTOXY(1,23);
  367.     WRITE('Please enter yearly maintenence costs for your instrument: $ ');
  368.     READ(MAINTENENCE);
  369.     CLEARLINES;
  370.       REPEAT
  371.         GOTOXY(1,23);
  372.         WRITE('Will an automated or semi-automated analyser be used? (Y/N): ');
  373.         READ(KBD,CH);
  374.           IF (CH = ('Y')) OR (CH = 'y') THEN
  375.             BEGIN
  376.               CLEARLINES;
  377.               GOTOXY(1,23);
  378.               WRITE
  379.               ('How many different tests, including ',TESTNAME,' is it doing: ');
  380.               READ(TOTALANATST);
  381.               CLEARLINES;
  382.               GOTOXY(1,23);
  383.               WRITELN
  384.               ('If you wish to enter this year''s depreciation allowance ');
  385.               WRITE('on the instrument, do so now, or enter `0'': $ ');
  386.               READ(DEPRECYR);
  387.               CLEARLINES;
  388.               GOTOXY(1,23);
  389.               WRITE
  390. ('How much reagent (in # of tests) are used to prime the analyser each run: ');
  391.               READ(PRIME);
  392.               CLEARLINES;
  393.             END
  394.           ELSE
  395.             CLEARLINES;
  396.       UNTIL
  397.         (CH = 'Y') OR (CH ='y') OR (CH = 'N') OR (CH = 'n');
  398.         END;
  399.         CLEARLINES;
  400.         GOTOXY(1,23);
  401.         WRITE('What is estimated Tech. time in minutes per batch run? : ');
  402.         READ(TECHTIME);
  403.         CLEARLINES;
  404.         GOTOXY(1,23);
  405.         WRITE('What is Tech salary / Hr? : $ ');
  406.         READ(TECHDOLLARS);
  407.         CLEARLINES;
  408.         GOTOXY(1,23);
  409.         WRITE
  410. ('To prepare Break-Even report, enter price you will charge for the test: $ ');
  411.         READ(YOURPRICE);
  412.         CLEARLINES;
  413.         GOTOXY(1,23);
  414.         WRITE
  415.  ('Please enter the Minimum number of Patients necessary to run a batch: ');
  416.         READ(STARTQTY);
  417.         CLEARLINES;
  418.           ENDQTY:= 0;INCRQTY:= 0;MAXBATCH:= 0;MAXHEADROOM:= 0;RUNSPERMONTH:= 1;
  419.         GOTOXY(1,23);
  420.         WRITE
  421.         ('Enter The Maximum number of Patients in a batch of ',TESTNAME,': ');
  422.         READ(ENDQTY);
  423.         CLEARLINES;
  424.         GOTOXY(1,23);
  425.         WRITE
  426.   ('For Break-Even report, what increments of patient quantities to show? : ');
  427.         READ(INCRQTY);
  428.         CLEARLINES;
  429.         GOTOXY(1,23);
  430.           REPEAT
  431.             WRITE
  432. ('What is the maximum batch size (blank,stds,ctrls,pts) you can run?: ');
  433.             READ(MAXBATCH);
  434.             CLEARLINES;
  435.             GOTOXY(1,23);
  436.             WRITE
  437.  ('For Batch run efficiency report, enter avg. # of patient spec / batch: ');
  438.             READ(MAXHEADROOM);
  439.               IF MAXHEADROOM > MAXBATCH THEN
  440.                 BEGIN
  441.                   CLEARLINES;
  442.                   GOTOXY(1,23);
  443.                   TEXTCOLOR(4);
  444.                   WRITELN
  445.     ('YOUR AVERAGE BATCH AMOUNT EXCEEDS YOUR MAXIMUM BATCH SIZE');
  446.                   TEXTCOLOR(0);
  447.                   WRITE('Press any key to continue');
  448.                   READ(KBD,CH);
  449.                   CLEARLINES;
  450.                 END;
  451.           UNTIL (MAXHEADROOM) <= (MAXBATCH);
  452.             CLEARLINES;
  453.             GOTOXY(1,23);
  454.             WRITE
  455. ('And, please enter the expected number of runs of ',TESTNAME,' per month: ');
  456.             READ(RUNSPERMONTH);
  457.             CLEARLINES;
  458.             GOTOXY(1,23);
  459.             WRITE('For a quick screen display, how many patients to run? : ');
  460.             SICKO:=1;
  461.             READ(SICKO);
  462.             CLEARLINES;
  463.  
  464. { ccccccccccccccccccccccccccccccc COMPUTATION AND FORMULAS ccccccccccccccccc }
  465.  
  466.   STANDARDCOST:= STANDARDSET / STANDARDLIFE;
  467.  
  468.   CONSUMPRICE:= CONSUMABLES / NUMCONSUMTST;
  469.  
  470.   PRIMECOST:= COSTTEST1 * PRIME;
  471.  
  472.   LABOR:= TECHTIME * (TECHDOLLARS / 60);
  473.  
  474.   DEPREC1:= DEPRECYR / (TOTALANATST * (RUNSPERMONTH * 12));
  475.  
  476.   UPKEEP := MAINTENENCE / (TOTALANATST * (12 * RUNSPERMONTH));
  477.  
  478.   COSTTEST1 := KITCOST / KITTESTS;
  479.  
  480.   SURVEY := QC / (TOTALANATST * (RUNSPERMONTH * 12));
  481.  
  482.   CALIBCSTRN := ((CALIBCST/CALIBLIFE)/RUNSPERMONTH);
  483.  
  484.   INITIAL := (COSTTEST1 * ((NUMCONTROLS * REPLICATE) + BLANK + NUMSTANDARDS)) +
  485.              DEPREC1 + (CONSUMPRICE *
  486.              (( NUMCONTROLS * REPLICATE) + BLANK + NUMSTANDARDS))
  487.              + SURVEY + LABOR + UPKEEP + STANDARDCOST + CALIBCSTRN + PRIMECOST;
  488.  
  489.   PTS := (COSTTEST1 * (SICKO * REPLICATE)) + (DRAW * SICKO)
  490.          + (CONSUMPRICE * SICKO);
  491.  
  492.   TESTCOST := (INITIAL + PTS)/ SICKO;
  493.  
  494.   RUNKITMONTH := RUNSPERMONTH / (KITTESTS /((REPLICATE *
  495.                  (NUMCONTROLS + MAXHEADROOM)) +
  496.                  (BLANK + NUMSTANDARDS) + (NUMCAL / (CALFREQ * 12)) +
  497.                  PRIME ));
  498.  
  499.   RUNCONSUMMONTH := NUMCONSUMTST /((REPLICATE*(NUMCONTROLS + MAXHEADROOM)) +
  500.                     (BLANK + NUMSTANDARDS));
  501.  
  502.   TESTPERMONTH := MAXHEADROOM * RUNSPERMONTH;
  503.  
  504.   VARIABLECOST:= ((COSTTEST1 * REPLICATE) + (CONSUMPRICE * REPLICATE) +
  505.                    DRAW);
  506.  
  507.   TOTALCOST:=INITIAL + (VARIABLECOST * CURQUAN);
  508.  
  509.   TOTALSALES:= YOURPRICE * CURQUAN;
  510.  
  511.   BREAKEVEN:= INITIAL / (YOURPRICE - VARIABLECOST);
  512.  
  513.   REVBRKEVEN:= YOURPRICE * BREAKEVEN;
  514.  
  515.   COSTBRKEVEN:= INITIAL + (VARIABLECOST * BREAKEVEN);
  516.  
  517. {****************************************************************************}
  518.  
  519.  
  520.     GOTOXY(10,17);                 { Give Quick Screen Answer }
  521.     TEXTCOLOR(14);
  522.     WRITE
  523.      ('Your run cost for ',SICKO,' pts for ',MAKER,'''s ',
  524.                                 TESTNAME,' is: $ ',TESTCOST * SICKO:2:2);
  525.     GOTOXY(10,19);
  526.     DELAY(4000);
  527.     WRITE
  528.     (' Thus, your cost per patient at this volume is: $',TESTCOST:2:2);
  529.     GOTOXY(4,21);
  530.     WRITE('So, with ',SICKO,' patient(s) on the run, profit is = $ ',
  531.                     YOURPRICE - TESTCOST:2:2,' per patient.');
  532.     GOTOXY(15,24);
  533.     TEXTCOLOR(2);
  534.     WRITE('       Peck any key to continue...  ');
  535.     READ(KBD,CH);
  536.     GRAPHBACKGROUND(3);
  537.     TEXTBACKGROUND(3);
  538.     CLRSCR;
  539.     GOTOXY(1,5);
  540.     TEXTCOLOR(0);
  541.     MAKEaLINE;
  542.     GOTOXY(1,6);
  543.     TEXTCOLOR(4);
  544.     MAKEaLINE;
  545.     GOTOXY(1,7);
  546.     TEXTCOLOR(15);
  547.     MAKEaLINE;
  548.     GOTOXY(10,10);
  549.     TEXTCOLOR(14);
  550.     WRITE('     PLEASE TURN ON YOUR PRINTER - AUTOMATIC PRINTOUT');
  551.     GOTOXY(10,15);
  552.     TEXTCOLOR(0);
  553.     WRITE('     Peck the `P'' key to begin printout or `N'' to QUIT: ');
  554.     READ(KBD,CH);
  555.       IF (CH = 'P') OR (CH = 'p') THEN
  556.  
  557.  
  558. {********************* Print Routine for GETIT ******************************}
  559.  
  560.   BEGIN
  561.                                                    { ***** PAGE 1 ***** }
  562.  
  563.     WRITE(LST,(CHR(27)),(CHR(69)));    { turn on emphasized pitch }
  564.     MAKEaBORDER(LST);
  565.     MAKEaBORDER(LST);
  566.     WRITE(LST,'                 ');
  567.     WRITELN(LST,'        TEST COST DATA ANALYSIS');
  568.     MAKEaBORDER(LST);
  569.     MAKEaBORDER(LST);
  570.     WRITELN(LST);
  571.     WRITELN(LST);
  572.     WRITELN(LST,'DONE AT: ',PLACENAME);
  573.     WRITELN(LST,'DATE: ',THISDATE);
  574.     WRITELN(LST);
  575.     WRITELN(LST,'TEST: ',TESTNAME);
  576.     WRITELN(LST,'MANUFACTURER: ',MAKER);
  577.     WRITELN(LST);
  578.     MAKEaBORDER(LST);
  579.     WRITELN(LST);
  580.     WRITELN(LST,'PACKAGE COST: $ ',KITCOST:3:2);
  581.     WRITELN(LST,'YIELD: ',KITTESTS,' Tests/Kit');
  582.     WRITELN(LST,'KIT TEST COST: $ ',KITCOST/KITTESTS:2:2,'/ Test');
  583.     WRITELN(LST,'CLAIMED SHELF LIFE: ',SHELFLIFE,' months');
  584.     WRITELN(LST,'RECONSTITUTED STABILITY: ',STABLELIFE);
  585.     WRITELN(LST,'USES: ',BLANK,' Blanks per run');
  586.     WRITELN(LST,'USES: ',NUMSTANDARDS,' Standards each run');
  587.     WRITELN(LST,'CALIBRATORS COST: $ ',CALIBCSTRN:2:2,' /run');
  588.     WRITELN(LST,'USES: ',NUMCONTROLS,' levels of Controls each run');
  589.     WRITELN
  590.         (LST,'REPLICATES: ',REPLICATE,
  591.            '   (1 = single  2 = controls/pts in duplicate)');
  592.     WRITELN(LST);
  593.     WRITELN(LST);
  594.     WRITELN(LST,'CONSUMABLES: $ ',CONSUMPRICE:2:2,' per test');
  595.     WRITELN(LST,'STANDARDS: $ ',STANDARDCOST:2:2,' per run');
  596.     WRITELN(LST,'DRAWING COSTS: $ ',DRAW:2:2,' per patient test');
  597.     WRITELN(LST,'TECH LABOR: $ ',LABOR:2:2,' per batch');
  598.     WRITELN(LST);
  599.     WRITELN(LST);
  600.     WRITELN
  601.      (LST,'INSTRUMENT DEPRECIATION: $ ',DEPREC1:2:2,' /this test/run day');
  602.     WRITELN(LST,'QC SURVEY COSTS: $ ',SURVEY:2:2,' /this test/run day');
  603.     WRITELN(LST,'MAINTENENCE COSTS: $ ',UPKEEP:2:2,'/this test/run day');
  604.     WRITELN(LST,'INITAL SETUP (no pts): $ ',INITIAL:2:2);
  605.     WRITELN(LST);
  606.     WRITELN(LST);
  607.     WRITE(LST,'TESTS / MONTH EXPECTED: ',RUNSPERMONTH * MAXHEADROOM);
  608.     WRITE(LST,'         ');
  609.     WRITELN(LST,'* EXPECTED KIT USE: ',RUNKITMONTH:2:1,' kits/month');
  610.     WRITE(LST,'                                    ');
  611.     WRITELN
  612.    (LST,'* EXPECTED DISPOSABLES LIFE: ',RUNCONSUMMONTH:2:1,' runs/pkg');
  613.     WRITE(LST,'                             ');
  614.     WRITELN
  615. (LST,'* ASSUMING ',MAXHEADROOM,' tests/batch and ',RUNSPERMONTH,' runs/month');
  616.     WRITELN(LST);
  617.     MAKEaBORDER(LST);
  618.     WRITELN(LST);
  619.     WRITELN(LST);
  620.     WRITELN
  621.   (LST,'CURRENT REFERENCE LAB PRICE: $ ',REFLAB:2:2,' per test for ',TESTNAME);
  622.     WRITELN(LST);
  623.     WRITELN
  624.     (LST,'PROPOSED CHARGE: $ ',YOURPRICE:2:2,' per test for ',TESTNAME);
  625.     WRITELN(LST);
  626.     WRITELN(LST);
  627.     MAKEaBORDER(LST);
  628.     MAKEaBORDER(LST);
  629.     WRITELN(LST);
  630.     WRITELN(LST);
  631.     WRITE(LST,'          ');
  632.     WRITELN
  633.     (LST,'SEE NEXT PAGES FOR BATCH RUN EFFICIENCY AND BREAK-EVEN ANALYSIS');
  634.     WRITE(LST,CHR(12));
  635.  
  636.  
  637.  { ********************************** PAGE 2 ******************************** }
  638.  
  639.     MAKEaBORDER(LST);
  640.     MAKEaBORDER(LST);
  641.     WRITE(LST,'                    ');
  642.     WRITELN(LST,'BATCH RUN EFFICIENCY ANALYSIS');
  643.     MAKEaBORDER(LST);
  644.     MAKEaBORDER(LST);
  645.     WRITELN(LST);
  646.     WRITELN(LST);
  647.     FOR SICKO := 1 TO MAXHEADROOM DO
  648.       BEGIN
  649.         WRITELN
  650.          (LST,'Cost of test/pt with ',SICKO,' patients = $ ',
  651.                      (INITIAL + (COSTTEST1 * (SICKO * REPLICATE)) +
  652.                      (DRAW * SICKO) + (CONSUMPRICE * SICKO))/SICKO:2:2);
  653.         WRITELN(LST);
  654.       END;
  655.     WRITELN(LST);
  656.     MAKEaBORDER(LST);
  657.     WRITELN(LST);
  658.     WRITELN
  659.     (LST,'Doing this test in-house with ',MAXHEADROOM,' pts saves you: $ ',
  660.        (REFLAB * MAXHEADROOM) - (INITIAL + (COSTTEST1 *
  661.        (MAXHEADROOM * REPLICATE)) + (DRAW * MAXHEADROOM) +
  662.        (CONSUMPRICE * MAXHEADROOM)):2:2);
  663.     WRITELN
  664.     (LST,'out of the reference lab liability of $ ',REFLAB * MAXHEADROOM:3:2);
  665.     WRITELN(LST,'for the same ',TESTNAME,'''s on ',MAXHEADROOM,' patients.');
  666.     WRITELN(LST);
  667.     WRITE(LST,CHR(12));
  668.  
  669.      { **************************** PAGE 3 ********************************** }
  670.  
  671.     WRITELN(LST);
  672.     MAKEaBORDER(LST);
  673.     WRITELN(LST,'                               COST BREAKDOWN');
  674.     WRITELN(LST);
  675.     WRITELN
  676.     (LST,'                      FOR ',MAXHEADROOM,' PT RUN COSTING   $ ',
  677.                ((TESTCOST*MAXHEADROOM)/2):3:2);
  678.  
  679. {cccccccccccccccccccccccccccccccc  Cost Breakdown Calculations cccccccccccccc}
  680.  
  681.           IF (INITIAL < 0.0001) THEN INITIAL:=0.0001;
  682.      CT:= CONSUMPRICE + COSTTEST1;
  683.      XT:= NUMSTANDARDS + BLANK + PRIME +
  684.           ((NUMCONTROLS + MAXHEADROOM)*REPLICATE);
  685.      VT:= 100*(CT*XT/(INITIAL + (COSTTEST1 *
  686.            (MAXHEADROOM *REPLICATE)) + (DRAW*MAXHEADROOM) + (CONSUMPRICE *
  687.            MAXHEADROOM)));  WRITELN(LST);  WRITE(LST, 'VARIABLE COSTS TOTAL: ',VT:3:1,' %');
  688.     WRITE(LST,'          ');
  689.     WRITELN(LST,'COST = $ ',((VT/100)*(TESTCOST * MAXHEADROOM)/2):3:2);  WRITELN(LST);
  690.     DT:=(CONSUMPRICE * MAXHEADROOM)/((TESTCOST * MAXHEADROOM)/2) * 100;
  691.     RT:=VT-DT;
  692.     WRITELN(LST,'       STDS/REAGENTS: ',RT:3:1,' %');
  693.     WRITELN(LST,'         DISPOSABLES: ',DT:3:1,' %');
  694.     WRITELN(LST);
  695.     WRITELN(LST);
  696.     WRITELN(LST);
  697.     WRITELN(LST);
  698.      FC:= 100 - VT;
  699.     WRITE(LST,'   FIXED COSTS TOTAL: ',FC:3:1,' %');
  700.     WRITE(LST,'         ');
  701.     WRITELN
  702.             (LST,' COST = $ ',(((TESTCOST * MAXHEADROOM)-
  703.                 ((VT/100) * (TESTCOST * MAXHEADROOM)))/2):3:2);
  704.     WRITELN(LST);
  705.     WRITELN(LST);
  706.     WRITELN(LST);
  707.     WRITELN(LST,'   (FIXED COSTS INCLUDE LABOR, DEPRECIATION & MAINTENENCE)');
  708.     WRITELN(LST);
  709.     WRITELN(LST);
  710.     MAKEaBORDER(LST);
  711.     WRITELN(LST);
  712.     WRITE(LST,CHR(12));
  713.  
  714. {******************************* PAGE 4 - BREAKEVEN **************************}
  715.  
  716.      WRITELN(LST);
  717.      MAKEaBORDER(LST);
  718.      WRITELN(LST);
  719.      WRITE(LST,'                      ');
  720.      WRITELN(LST,'BREAKEVEN TABLE FOR ',TESTNAME);
  721.      WRITELN(LST);
  722.      MAKEaBORDER(LST);
  723.       IF (STARTQTY < 1) THEN STARTQTY:=1;
  724.       CURQUAN:= STARTQTY;
  725.      WRITELN(LST);
  726.      WRITE(LST,'        QTY       TOTAL COST     TOTAL BILLED');
  727.      WRITELN(LST,'     GAIN/LOSS     UNIT COST');
  728.      MAKEaBORDER(LST);
  729.      WRITELN(LST);
  730.      IF (ENDQTY < 2) THEN ENDQTY:=2;
  731.      IF (INCRQTY < 1) THEN INCRQTY:=1;
  732.      WHILE (CURQUAN <= ENDQTY) DO
  733.        BEGIN
  734.           TOTALSALES := YOURPRICE * CURQUAN;
  735.           TOTALCOST := INITIAL + (VARIABLECOST * CURQUAN);
  736.           UNITCOST := TOTALCOST / CURQUAN;
  737.           PROFLOSS := TOTALSALES - TOTALCOST;
  738.          WRITELN(LST,'   ',CURQUAN:7,'   ',TOTALCOST:12:2,'   ',
  739.                      TOTALSALES:12:2,'   ',PROFLOSS:12:2,'   ',
  740.                      UNITCOST:12:2);
  741.           CURQUAN := CURQUAN + INCRQTY;
  742.        END;
  743.      WRITELN(LST);
  744.      MAKEaBORDER(LST);
  745.       CURQUAN := TRUNC(BREAKEVEN);
  746.      WRITELN(LST,'   ',CURQUAN:7,'   ',COSTBRKEVEN:12:2,'   ',
  747.              REVBRKEVEN:12:2,' = BREAKEVEN POINT');
  748.      MAKEaBORDER(LST);
  749.      WRITELN(LST);
  750.      WRITELN(LST,'      TOTAL FIXED COST (no Pts):$',INITIAL:12:2);
  751.      WRITELN(LST,'      VARIABLE COSTS / TEST     $',VARIABLECOST:12:2);
  752.      WRITELN(LST,'      BILLING PRICE / TEST      $',YOURPRICE:12:2);
  753.      WRITELN(LST);
  754.      MAKEaBORDER(LST);
  755.      WRITELN(LST);
  756.      WRITELN(LST);
  757.      WRITELN(LST);
  758.        IF (YOURPRICE > REVBRKEVEN) THEN
  759.          BEGIN
  760.            WRITE(LST,'          ');
  761.            WRITELN
  762.  (LST,'**** At Your Price, You Profit With Even The Smallest Increment ****');
  763.            WRITELN(LST);
  764.          END;
  765.      WRITELN(LST);
  766.      WRITELN(LST);
  767.      WRITELN
  768.      (LST,'            END OF REPORT FOR ',MAKER,'''S ',TESTNAME,' ANALYSIS');
  769.      WRITELN(LST);
  770.      WRITELN(LST);
  771.      WRITELN
  772.  (LST,'  | Please Note: Use of Real Numbers in calculations usually yields slight |');
  773.      WRITELN
  774.  (LST,'  |      ( less than 1% ) inaccuracies or inconsistencies in calculations. |');
  775.      WRITE(LST,CHR(12));
  776.    END
  777. END;
  778.  
  779. {************************* Escape Routine for GETIT ************************ }
  780.  
  781.  
  782. PROCEDURE CHOOSE;
  783.  
  784.     BEGIN
  785.       TEXTBACKGROUND(4);          { 1st is to get out of GETIT }
  786.       TEXTCOLOR(14);
  787.       CLRSCR;
  788.       GOTOXY(20,9);
  789.       WRITE('THE FOLLOWING PROCEDURE IS VERY LONG.');
  790.       GOTOXY(17,11);
  791.       TEXTCOLOR(1);
  792.       WRITE('You will need information from PRINT VARIABLES');
  793.       GOTOXY(17,13);
  794.       TEXTCOLOR(15);
  795.       WRITE('Peck the `Y'' key to Continue or `N'' to Escape: ');
  796.       READ(KBD,CH);
  797.         IF CH = 'Y' THEN GETIT;
  798.         IF CH = 'y' THEN GETIT;
  799.     END;
  800.  
  801. {******************* Instrument Depreciation Main Routine *******************}
  802.  
  803.  
  804. PROCEDURE DEPREC;
  805.  
  806.   TYPE
  807.     DEPRECTYPE = (SL,SOYD,DB);
  808.     STRINGTYPE = STRING[80];
  809.  
  810.   VAR                                {the core variables are self-explanatory}
  811.     I, L : INTEGER;
  812.     CH : CHAR;
  813.     ALLDONE : BOOLEAN;
  814.     BOOKVALUE, CUMDEPREC, CURRENTYR,
  815.     DBFACTOR, SCRAPVALUE, STRAIGHTLINE,
  816.     USEFULLIFE, YRSLEFT,AQUISCOST                            : REAL;
  817.     ITEMDESCR, ITEMNAME                                      : STRINGTYPE;
  818.     LISTOUT                                                  : TEXT;
  819.  
  820.   {  ####################### INTERNAL PROCEDURES TO DEPREC ##################}
  821.  
  822.     PROCEDURE SIGNON;              { initial fancy screen }
  823.  
  824.        BEGIN
  825.          TEXTBACKGROUND(1);
  826.          GRAPHBACKGROUND(1);
  827.          CLRSCR;
  828.          GOTOXY(1,10);
  829.          TEXTCOLOR(4);
  830.          MAKEaLINE;
  831.          GOTOXY(1,11);
  832.          TEXTCOLOR(7);
  833.          MAKEaLINE;
  834.          GOTOXY(1,15);
  835.          TEXTCOLOR(7);
  836.          MAKEaLINE;
  837.          GOTOXY(1,16);
  838.          TEXTCOLOR(4);
  839.          MAKEaLINE;
  840.          GOTOXY(22,13);
  841.          TEXTCOLOR(15);
  842.          WRITE('THREE-METHOD DEPRECIATION CALCULATOR');
  843.          GOTOXY(10,20);
  844.          HIGHVIDEO;
  845.          TEXTBACKGROUND(1);
  846.          WRITE('   *** Printout is automatic. Please turn on printer ***');
  847.          DELAY(6000);
  848.          CLRSCR;
  849.        END;
  850.  
  851.      PROCEDURE GETDATA;            { Gets Data!! }
  852.  
  853.        BEGIN
  854.          TEXTBACKGROUND(0);
  855.          GRAPHBACKGROUND(0);
  856.          CLRSCR;
  857.          GOTOXY(1,5);
  858.          TEXTCOLOR(4);
  859.          MAKEaLINE;
  860.          GOTOXY(1,6);
  861.          TEXTCOLOR(15);
  862.          MAKEaLINE;
  863.          GOTOXY(1,7);
  864.          TEXTCOLOR(1);
  865.          MAKEaLINE;
  866.          GOTOXY(5,9);
  867.          TEXTCOLOR(7);
  868.          WRITE('Enter name of the item to be depreciated: ');
  869.          READLN(ITEMNAME);
  870.          WRITELN;
  871.          GOTOXY(5,11);
  872.          WRITE('Short description of ',ITEMNAME,': ');
  873.          READLN(ITEMDESCR);
  874.          WRITELN;
  875.          GOTOXY(5,13);
  876.          WRITE('Give aquisition cost of ',ITEMNAME,' (NO COMMAS):$  ');
  877.          READLN(AQUISCOST);
  878.          WRITELN;
  879.          GOTOXY(5,15);
  880.          WRITE('Enter the useful life in years: ');
  881.          READLN(USEFULLIFE);
  882.          WRITELN;
  883.          GOTOXY(5,17);
  884.          WRITE
  885.   ('Enter the scrap value at end of ',USEFULLIFE:2:0,' years (NO COMMAS):$  ');
  886.          READLN(SCRAPVALUE);
  887.          WRITELN;
  888.          GOTOXY(5,19);
  889.          WRITE('Factor (%) for Declining Balance calculations is: ');
  890.          READLN(DBFACTOR);
  891.          CLRSCR;
  892.        END;
  893.  
  894.      PROCEDURE METHODHEADERS(VAR LISTOUT:TEXT ; WHATKIND:DEPRECTYPE);
  895.  
  896.                                   { sets up report headers }
  897.        BEGIN
  898.          WRITELN(LISTOUT);
  899.            CASE (WHATKIND) OF
  900.              SL : WRITELN(LISTOUT,'==========>> STRAIGHT-LINE METHOD');
  901.              SOYD : WRITELN(LISTOUT,'==========>> SUM-OF-YEARS-DIGITS');
  902.              DB : WRITELN
  903.              (LISTOUT,'==========>> DECLINING BALANCE with ',DBFACTOR:5:2
  904.                    ,' PERCENT FACTOR');
  905.            END;
  906.          WRITELN(LISTOUT);
  907.          WRITELN
  908.          (LISTOUT,'         Current Year       Cumulative          Book');
  909.          WRITELN(LISTOUT,
  910.                  'Year     Depreciation       Depreciation       Value');
  911.          WRITELN(LISTOUT,
  912.                  '------------------------------------------------------')
  913.       END;
  914.  
  915.    PROCEDURE PRINTmainHEADINGS;      { Prints main headings of Report!! }
  916.  
  917.      BEGIN
  918.        WRITE(LST,(CHR(27)),(CHR(69)));
  919.        MAKEaBORDER(LST);
  920.        WRITELN(LISTOUT);
  921.        WRITE(LISTOUT,'                     ');
  922.        WRITELN(LISTOUT,'    DEPRECIATION SCHEDULES');
  923.        MAKEaBORDER(LST);
  924.        WRITELN(LISTOUT);
  925.        WRITELN(LISTOUT);
  926.        WRITELN(LISTOUT,'Name of the item to be depreciated: ',ITEMNAME);
  927.        WRITELN(LISTOUT,ITEMNAME,' described as: ',ITEMDESCR);
  928.        WRITELN(LISTOUT,'Aquisition cost: $',AQUISCOST:6:2);
  929.        WRITELN(LISTOUT,'Useful life is ',USEFULLIFE:2:0,' years');
  930.        WRITELN(LISTOUT,'Scrap value at end of ',USEFULLIFE:2:0,' years: $',
  931.                 SCRAPVALUE:6:2);
  932.        WRITELN(LISTOUT);
  933.        TEXTBACKGROUND(1);
  934.        GRAPHBACKGROUND(1);
  935.        CLRSCR;
  936.        GOTOXY(1,5);
  937.        TEXTCOLOR(0);
  938.        MAKEaLINE;
  939.        GOTOXY(1,6);
  940.        TEXTCOLOR(15);
  941.        MAKEaLINE;
  942.        GOTOXY(1,7);
  943.        TEXTCOLOR(4);
  944.        MAKEaLINE;
  945.        GOTOXY(1,9);
  946.        TEXTCOLOR(0);
  947.        WRITELN(CON,'Name of the item to be depreciated: ',ITEMNAME);
  948.        WRITELN(CON,ITEMNAME,' described as: ',ITEMDESCR);
  949.        WRITELN(CON,'Aquisition cost: $',AQUISCOST:6:2);
  950.        WRITELN(CON,'Useful life is ',USEFULLIFE:2:0,' years.');
  951.        WRITELN(CON,'Scrap value at end of ',USEFULLIFE:2:0,' years: $',
  952.                      SCRAPVALUE:6:2);
  953.        WRITELN(CON);
  954.      END;
  955.  
  956.    PROCEDURE WRITEVALUE (VAR LISTOUT:TEXT; YEARNUM,CURYR,CUMUL,BOOK:REAL);
  957.  
  958.                                     { claculates and adds data to printout }
  959.  
  960.      BEGIN
  961.        WRITELN(LISTOUT,YEARNUM:2:0,'       ',CURYR:10:2,'       ',CUMUL:10:2,
  962.                '       ',BOOK:10:2)
  963.      END;
  964.  
  965.    { ############### END OF INTERNAL PROCEDURES FOR DEPREC ############## }
  966.  
  967.   BEGIN                        { Main Procedure DEPREC Code }
  968.     ASSIGN(LISTOUT,'LST:');
  969.     REWRITE(LISTOUT);
  970.     CLRSCR;
  971.     SIGNON;
  972.     GETDATA;
  973.     PRINTmainHEADINGS;
  974.     TEXTCOLOR(4);
  975.     METHODHEADERS(CON,SL);
  976.     TEXTCOLOR(0);
  977.     METHODHEADERS(LISTOUT,SL);
  978.     CUMDEPREC := 0;
  979.     WRITEVALUE(CON,0,0,0,AQUISCOST);
  980.     WRITEVALUE(LISTOUT,0,0,0,AQUISCOST);
  981.       FOR I := 1 TO TRUNC(USEFULLIFE) DO
  982.         BEGIN
  983.           CURRENTYR := (AQUISCOST - SCRAPVALUE)/USEFULLIFE;
  984.           CUMDEPREC := CUMDEPREC + CURRENTYR;
  985.           BOOKVALUE := AQUISCOST - CUMDEPREC;
  986.           STRAIGHTLINE := (USEFULLIFE * USEFULLIFE + USEFULLIFE)/2.0;
  987.         WRITEVALUE(CON,I,CURRENTYR,CUMDEPREC,BOOKVALUE);
  988.         WRITEVALUE(LISTOUT,I,CURRENTYR,CUMDEPREC,BOOKVALUE)
  989.       END;
  990.     TEXTCOLOR(4);
  991.     METHODHEADERS(CON,SOYD);
  992.     TEXTCOLOR(0);
  993.     METHODHEADERS(LISTOUT,SOYD);
  994.     CUMDEPREC := 0;
  995.     WRITEVALUE(CON,0,0,0,AQUISCOST);
  996.     WRITEVALUE(LISTOUT,0,0,0,AQUISCOST);
  997.       FOR I := 1 TO TRUNC(USEFULLIFE) DO
  998.         BEGIN
  999.           YRSLEFT := USEFULLIFE - I + 1;
  1000.           CURRENTYR := YRSLEFT / STRAIGHTLINE * (AQUISCOST - SCRAPVALUE);
  1001.           CUMDEPREC := CUMDEPREC + CURRENTYR;
  1002.           BOOKVALUE := AQUISCOST - CUMDEPREC;
  1003.           WRITEVALUE(CON,I,CURRENTYR,CUMDEPREC,BOOKVALUE);
  1004.           WRITEVALUE(LISTOUT,I,CURRENTYR,CUMDEPREC,BOOKVALUE);
  1005.         END;
  1006.     TEXTCOLOR(4);
  1007.     METHODHEADERS(CON,DB);
  1008.     TEXTCOLOR(0);
  1009.     METHODHEADERS(LISTOUT,DB);
  1010.     CUMDEPREC := 0;
  1011.     WRITEVALUE(CON,0,0,0,AQUISCOST);
  1012.     WRITEVALUE(LISTOUT,0,0,0,AQUISCOST);
  1013.     DBFACTOR := (DBFACTOR / 100.0) / USEFULLIFE;
  1014.     CURRENTYR := AQUISCOST * DBFACTOR;
  1015.     I := 1;
  1016.     ALLDONE := FALSE;
  1017.       REPEAT
  1018.         YRSLEFT := USEFULLIFE - I +1;
  1019.         CUMDEPREC := CUMDEPREC + CURRENTYR;
  1020.         BOOKVALUE := AQUISCOST - CUMDEPREC;
  1021.         WRITEVALUE(CON,I,CURRENTYR,CUMDEPREC,BOOKVALUE);
  1022.         WRITEVALUE(LISTOUT,I,CURRENTYR,CUMDEPREC,BOOKVALUE);
  1023.         CURRENTYR := BOOKVALUE * DBFACTOR;
  1024.         I := I +1;
  1025.           IF (BOOKVALUE < SCRAPVALUE) THEN
  1026.             BEGIN
  1027.               ALLDONE := TRUE;
  1028.               WRITELN;
  1029.               WRITELN(LISTOUT);
  1030.               WRITELN('Cannot take depreciation below book value of $',
  1031.                     SCRAPVALUE:6:2);
  1032.               WRITELN(LISTOUT,'Cannot take depreciation below book value of $',
  1033.                    SCRAPVALUE:6:2);
  1034.             END;
  1035.               IF (I > TRUNC(USEFULLIFE)) THEN
  1036.                 ALLDONE := TRUE;
  1037.       UNTIL (ALLDONE);
  1038.       WRITELN(LISTOUT);
  1039.       WRITELN(LISTOUT);
  1040.       WRITELN(LISTOUT);
  1041.       MAKEaBORDER(LST);
  1042.       WRITELN(LISTOUT);
  1043.       WRITELN(LISTOUT);
  1044.       MAKEaBORDER(LST);
  1045.       WRITELN(LISTOUT,CHR(12));
  1046.       WRITELN(CON);
  1047.       WRITELN(CON);
  1048.       TEXTCOLOR(4);
  1049.       WRITELN(CON,'                      *** ALL DONE ***',CHR(7));
  1050.  
  1051.     END;
  1052.  
  1053. {************* Prints Out the Variables list for Cost/Test routine **********}
  1054.  
  1055.  
  1056.  
  1057. PROCEDURE PRINTVAR;
  1058.  
  1059.   BEGIN
  1060.  
  1061.     GRAPHBACKGROUND(3);
  1062.     TEXTBACKGROUND(3);
  1063.     CLRSCR;
  1064.     GOTOXY(1,5);
  1065.     TEXTCOLOR(0);
  1066.     MAKEaLINE;
  1067.     GOTOXY(1,6);
  1068.     TEXTCOLOR(4);
  1069.     MAKEaLINE;
  1070.     GOTOXY(1,7);
  1071.     TEXTCOLOR(15);
  1072.     MAKEaLINE;
  1073.     GOTOXY(10,10);
  1074.     TEXTCOLOR(14);
  1075.     WRITE('    PLEASE TURN ON YOUR PRINTER - AUTOMATIC PRINTOUT');
  1076.     GOTOXY(10,15);
  1077.     TEXTCOLOR(4);
  1078.     WRITE('    Peck the `P'' key to begin printout or `N'' to QUIT: ');
  1079.     READ(KBD,CH);
  1080.       IF (CH = 'P') OR (CH = 'p') THEN
  1081.      BEGIN
  1082.       WRITE(LST,(CHR(27)),(CHR(69)));
  1083.       WRITELN(LST);
  1084.       WRITELN(LST);
  1085.       MAKEaBORDER(LST);
  1086.       WRITELN(LST);
  1087.       WRITELN(LST,'                    **** TEST COST VARIABLES LIST **** ');
  1088.       WRITELN(LST);
  1089.       MAKEaBORDER(LST);
  1090.       WRITELN(LST);
  1091.       WRITELN(LST);
  1092.       WRITELN
  1093.       (LST,'     You will need to have the following information available');
  1094.       WRITELN(LST,'     for entry into the test cost analysis:');
  1095.       WRITELN(LST);
  1096.       WRITELN(LST,'     1. The name of your facility or lab.');
  1097.       WRITELN(LST,'     2. Today''s date.');
  1098.       WRITELN(LST,'     3. The test name.');
  1099.       WRITELN(LST,'     4. The kit or system manufacturer''s name.');
  1100.       WRITELN(LST,'     5. The price / kit. ');
  1101.       WRITELN(LST,'     6. The number of tests / kit.');
  1102.       WRITELN
  1103.       (LST,'     7. The averaged claimed shelf life (months) of the kit.');
  1104.       WRITELN
  1105.       (LST,'     8. Reconstitued stability of reagents (hours or days).');
  1106.       WRITELN
  1107.    (LST,'     9. The number of est. tests / month (incl blank,stds,ctrls).');
  1108.       WRITELN(LST,'    10. Any new yearly cost for QC survey specimens.');
  1109.       WRITELN(LST,'    11. The number of control levels used /run.');
  1110.       WRITELN(LST,'    12. Cost for calibrators if they''re used.');
  1111.       WRITELN
  1112.       (LST,'    13. Some quest. about calibration frequency and numbers.');
  1113.       WRITELN(LST,'    14. The number of standards / run.');
  1114.       WRITELN
  1115.       (LST,'    15. If not part of the kit, the cost of the Standards.');
  1116.       WRITELN
  1117.       (LST,'    16. The expected number of runs to use up the standards.');
  1118.       WRITELN(LST,'    17. The number of blanks / run.');
  1119.       WRITELN(LST,'    18. Whether you''re running singly or in duplicate.');
  1120.       WRITELN(LST,'    19. Price / known quantity package of consumables.');
  1121.       WRITELN
  1122.       (LST,'    20. The number of tests / package of those consumables.');
  1123.       WRITELN
  1124.       (LST,'    21. Estimated or known blood drawing/preparation costs.');
  1125.       WRITELN
  1126.       (LST,'    22. Maximum batch size / run (incl blanks, stds, ctrls).');
  1127.       WRITELN(LST,'    23. Price for similar test at your reference lab.');
  1128.       WRITELN
  1129.  (LST,'    24. Whether the test uses an automated or semi-auto analyser.');
  1130.       WRITELN
  1131.     (LST,'    25. If so, how many different tests the analyser is doing.');
  1132.       WRITELN
  1133.      (LST,'    26. If you''re using depreciation allowance, this yrs amount.');
  1134.       WRITELN(LST,'    27. A tentative price you''ll charge for the test.');
  1135.       WRITELN
  1136.    (LST,'    28. An estimate of the average number of patient spec / batch.');
  1137.       WRITELN(LST,'    29. Estimated Tech time in minutes to run a batch.');
  1138.       WRITELN(LST,'    30. Tech salary in $ / Hr.');
  1139.       WRITELN
  1140.       (LST,'    31. Yearly maintenence/service charges for instrument.');
  1141.       WRITELN
  1142.  (LST,'    32. The # of tests of reagent your analyser uses to prime itself ');
  1143.       WRITELN(LST,'        before running a batch.');
  1144.       WRITELN(LST);
  1145.       WRITELN(LST);
  1146.       WRITELN(LST);
  1147.       MAKEaBORDER(LST);
  1148.       WRITELN(LST);
  1149.       WRITELN
  1150.     (LST,'     As you can see, I''m not going to supply you with CAP Workload');
  1151.       WRITELN
  1152.       (LST,'units, just simple labor estimates.  Labor is a very large and');
  1153.       WRITELN
  1154.    (LST,'important part of test costing.  However my feeling is that no one ');
  1155.       WRITELN
  1156.       (LST,'way of workload accounting is best for all situations - So just');
  1157.       WRITELN
  1158. (LST,'pick a method you like, or use my simple batch labor as the add on to');
  1159.       WRITELN
  1160.    (LST,'the cost / test data from this program.  Also, because most full, ');
  1161.       WRITELN
  1162.    (LST,'instrument calibrations are infrequent, calibrator use of reagent ');
  1163.       WRITELN(LST,'and consumables is NOT figured into test cost directly.');
  1164.       WRITELN(LST);
  1165.       MAKEaBORDER(LST);
  1166.       WRITELN(LST);
  1167.       WRITELN(LST);
  1168.       MAKEaBORDER(LST);
  1169.       WRITE(LST,CHR(12));
  1170.      END
  1171.    END;
  1172.  
  1173. {******************************* Escape from DEPREC **************************}
  1174.  
  1175.  PROCEDURE GETOUT;
  1176.    BEGIN
  1177.      TEXTBACKGROUND(1);
  1178.      CLRSCR;
  1179.      GOTOXY(15,10);
  1180.      TEXTCOLOR(15);
  1181.      WRITELN(' DEPRECIATION PROGRAM - PRINTER MUST BE READY');
  1182.      GOTOXY(15,13);
  1183.      TEXTCOLOR(4);
  1184.      WRITE('Peck `Y'' to continue or `N'' to return to menu: ');
  1185.      READ(KBD,CH);
  1186.      IF CH = 'Y' THEN DEPREC;
  1187.      IF CH = 'y' THEN DEPREC;
  1188.   END;
  1189.  
  1190. {********************************** Statisitics Procedure ******************}
  1191.  
  1192. PROCEDURE STATS;
  1193.  
  1194.   CONST
  1195.     MAX = 81;
  1196.  
  1197.   TYPE
  1198.     STR80 = STRING[80];
  1199.     DATAITEM = REAL;
  1200.     DATAARRAY = ARRAY[1..MAX] OF DATAITEM;
  1201.  
  1202.   VAR
  1203.     CH:CHAR;
  1204.     DATA:DATAARRAY;
  1205.     NUM,T:INTEGER;
  1206.     A,M,MD,STD,AVG:REAL;
  1207.     ENTERED,QUIT:BOOLEAN;
  1208.     DATANAME:STRING[40];
  1209.  
  1210.     PROCEDURE SIGNON;                { initial screen }
  1211.  
  1212.       BEGIN
  1213.         GRAPHBACKGROUND(1);
  1214.         TEXTBACKGROUND(1);
  1215.         CLRSCR;
  1216.         GOTOXY(15,8);
  1217.         LOWVIDEO;
  1218.         FOR I:=1 TO 50 DO
  1219.           BEGIN
  1220.             WRITE(CHR(205))
  1221.           END;
  1222.         GOTOXY(14,10);
  1223.         HIGHVIDEO;
  1224.         TEXTBACKGROUND(1);
  1225.         TEXTCOLOR(4);
  1226.         WRITE('STATISTICS: SD - MEAN - MEDIAN - MIN/MAX - 2SD RANGE');
  1227.         GOTOXY(15,12);
  1228.         LOWVIDEO;
  1229.         FOR J:=1 TO 50 DO
  1230.           BEGIN
  1231.             WRITE(CHR(205))
  1232.           END;
  1233.         DELAY(3000);
  1234.         CLRSCR;
  1235.       END;
  1236.  
  1237.   PROCEDURE QUICKSORT (VAR ITEM:DATAARRAY;COUNT:INTEGER);
  1238.  
  1239.      PROCEDURE QS (L,R:INTEGER; VAR IT:DATAARRAY);
  1240.         VAR
  1241.           I,J:INTEGER;
  1242.           X,Y:DATAITEM;                { quicksort used to help median calc }
  1243.             BEGIN
  1244.               I:=L; J:=R;
  1245.               X:=IT[(L+R) DIV 2];
  1246.               REPEAT
  1247.                 WHILE IT[I] < X DO I:= I+1;
  1248.                 WHILE X < IT[J] DO J:= J-1;
  1249.                 IF I <= J THEN
  1250.                 BEGIN
  1251.                   Y:= IT[I];
  1252.                   IT[I]:= IT[J];
  1253.                   IT[J]:= Y;
  1254.                   I:= I+1; J:= J-1;
  1255.                 END;
  1256.               UNTIL I > J;
  1257.               IF L < J THEN QS(L,J,IT);
  1258.               IF L < R THEN QS(I,R,IT)
  1259.             END;
  1260.           BEGIN
  1261.             QS(1,COUNT,ITEM);
  1262.           END;
  1263.         FUNCTION ISIN(CH:CHAR;S:STR80):BOOLEAN;
  1264.           VAR
  1265.             T:INTEGER;
  1266.  
  1267.           BEGIN
  1268.             ISIN:=FALSE;
  1269.             FOR T:=1 TO LENGTH(S) DO
  1270.               IF S[T]=CH THEN ISIN:= TRUE;
  1271.           END;   { maybe }
  1272.  
  1273.         FUNCTION MENU:CHAR;
  1274.  
  1275.          VAR
  1276.            CH:CHAR;
  1277.  
  1278.          BEGIN
  1279.            GRAPHBACKGROUND(1);
  1280.            TEXTBACKGROUND(1);
  1281.            CLRSCR;
  1282.            WRITELN;
  1283.            TEXTCOLOR(0);
  1284.            REPEAT
  1285.              WRITELN('[D] = Run Q-Chart QC Graph & Statistics Routine - PRINTER REQD.');
  1286.              WRITELN('[E] = Enter Data');
  1287.              WRITELN('[B] = Display & Perform Statistics on Entered Data');
  1288.              WRITELN('[Q] = Quit');
  1289.              WRITELN;
  1290.              TEXTCOLOR(4);
  1291.              WRITE('Please Peck A Letter: ');
  1292.              TEXTCOLOR(0);
  1293.              READ(KBD,CH); WRITELN;
  1294.              CH:=UPCASE(CH);
  1295.            UNTIL ISIN(CH,'EDBQ');
  1296.            MENU := CH;
  1297.            GOTOXY(1,7);
  1298.            CLREOL;
  1299.          END;
  1300.  
  1301.     PROCEDURE DISPLAY (DATA:DATAARRAY;NUM:INTEGER);
  1302.  
  1303.       VAR
  1304.         T:INTEGER;
  1305.         Y:INTEGER;
  1306.       BEGIN
  1307.         TEXTBACKGROUND(1);
  1308.         GOTOXY(1,1);
  1309.         TEXTCOLOR(14);
  1310.         CLRSCR;
  1311.         WRITELN('                        DATA FOR: ',DATANAME);
  1312.         BEGIN
  1313.          IF (NUM <= 20) THEN
  1314.           BEGIN
  1315.            GOTOXY(1,3);
  1316.            FOR T:=1 TO NUM DO WRITELN('   ',T:2,': ',DATA[T]:5:2);
  1317.            WRITELN;
  1318.           END
  1319.          ELSE
  1320.          IF (NUM > 20) AND (NUM <= 40) THEN
  1321.            BEGIN
  1322.             GOTOXY(1,3);
  1323.             FOR T:= 21 TO NUM DO WRITELN
  1324.             ('                      ',T,': ',DATA[T]:5:2);
  1325.             GOTOXY(1,3);
  1326.             FOR T:= 1 TO 20 DO WRITELN('   ',T:2,': ',DATA[T]:5:2);
  1327.            END
  1328.          ELSE
  1329.          IF (NUM > 40) AND (NUM <=60) THEN
  1330.            BEGIN
  1331.             GOTOXY(1,3);
  1332.             FOR T:=41 TO NUM DO WRITELN
  1333.             ('                                     ',T,': ',DATA[T]:5:2);
  1334.             GOTOXY(1,3);
  1335.             FOR T:= 21 TO 40 DO WRITELN
  1336.             ('                      ',T,': ',DATA[T]:5:2);
  1337.             GOTOXY(1,3);
  1338.             FOR T:=1 TO 20 DO WRITELN('   ',T:2,': ',DATA[T]:5:2);
  1339.            END
  1340.          ELSE
  1341.          IF (NUM > 60) AND (NUM <= 80) THEN
  1342.            BEGIN
  1343.             GOTOXY(1,3);
  1344.             FOR T:=61 TO NUM DO WRITELN
  1345. ('                                                          ',T,': ',DATA[T]:5:2);
  1346.             GOTOXY(1,3);
  1347.             FOR T:= 41 TO 60 DO WRITELN
  1348.             ('                                       ',T,': ',DATA[T]:5:2);
  1349.             GOTOXY(1,3);
  1350.             FOR T:=21 TO 40 DO WRITELN
  1351.             ('                     ',T,': ',DATA[T]:5:2);
  1352.             GOTOXY(1,3);
  1353.             FOR T:=1 TO 20 DO WRITELN('   ',T:2,': ',DATA[T]:5:2);
  1354.            END;
  1355.         END;
  1356.          GOTOXY(20,24);
  1357.          TEXTCOLOR(4);
  1358.          WRITE('Peck Any Key To Continue (or Shft-PrtSc to print): ');
  1359.          READ(KBD,CH);
  1360.       END;
  1361.  
  1362.    PROCEDURE ENTER (VAR DATA:DATAARRAY);
  1363.  
  1364.      VAR
  1365.        T:INTEGER;
  1366.  
  1367.    BEGIN
  1368.        TEXTBACKGROUND(1);
  1369.        TEXTCOLOR(0);
  1370.      REPEAT
  1371.        ENTERED := FALSE;
  1372.        GOTOXY(5,10);
  1373.        WRITE('How Many Data Items (1 to 80) ? :  ');
  1374.        TEXTCOLOR(15);
  1375.        READ(NUM);
  1376.          IF (NUM > 80) THEN
  1377.            BEGIN
  1378.              SOUND(500);
  1379.              DELAY(700);
  1380.              NOSOUND;
  1381.              GOTOXY(15,23);
  1382.              TEXTCOLOR(14);
  1383.              WRITE('HEY!!!! FOLLOW DIRECTIONS FOR ARRAY SIZE!!!');
  1384.              DELAY(2000);
  1385.              CLEARLINES;
  1386.              GOTOXY(5,10);
  1387.              CLREOL;
  1388.            END;
  1389.      UNTIL (NUM <= 80);
  1390.        WRITELN;
  1391.        GOTOXY(5,12);
  1392.        WRITE('Enter Heading for Data (1-40 char): ');
  1393.        READ(DATANAME);
  1394.        WRITELN;
  1395.        FOR T:=1 TO NUM DO
  1396.          BEGIN
  1397.            TEXTCOLOR(0);
  1398.            GOTOXY(5,23);
  1399.            WRITE('Enter Item ',t,' : ');
  1400.            TEXTCOLOR(15);
  1401.            READ(DATA[T]);
  1402.            CLEARLINES;
  1403.          END;
  1404.        GOTOXY(1,24);
  1405.        TEXTCOLOR(4);
  1406.        SOUND(300);
  1407.        DELAY(600);
  1408.        NOSOUND;
  1409.        WRITE
  1410.      ('OK, That''s It - Peck Any Key to Continue: ');
  1411.        READ(KBD,CH);
  1412.        ENTERED := TRUE;
  1413.    END;
  1414.  
  1415.   FUNCTION MEAN(DATA:DATAARRAY;NUM:INTEGER):REAL;
  1416.  
  1417.    VAR
  1418.      T:INTEGER;
  1419.      AVG:REAL;
  1420.  
  1421.    BEGIN
  1422.      AVG:=0;
  1423.      FOR T:=1 TO NUM DO AVG:=AVG+DATA[T];
  1424.      MEAN:=AVG/NUM;
  1425.    END;
  1426.  
  1427.   FUNCTION STDDEV (DATA:DATAARRAY;NUM:INTEGER):REAL;
  1428.  
  1429.     VAR
  1430.       T:INTEGER;
  1431.       STD,AVG:REAL;
  1432.  
  1433.     BEGIN
  1434.       AVG:=MEAN(DATA,NUM);
  1435.       STD:=0;
  1436.       FOR T:= 1 TO NUM DO
  1437.         STD:=STD+((DATA[T]-AVG)*(DATA[T]-AVG));
  1438.       STD:=STD/NUM;
  1439.       STDDEV:=SQRT(STD);
  1440.     END;
  1441.  
  1442.    FUNCTION MEDIAN (DATA:DATAARRAY;NUM:INTEGER):REAL;
  1443.  
  1444.      VAR
  1445.        DTEMP:DATAARRAY;
  1446.        T:INTEGER;
  1447.  
  1448.      BEGIN
  1449.        MEDIAN:=1;
  1450.        FOR T:=1 TO NUM DO DTEMP[T]:=DATA[T];
  1451.        QUICKSORT(DTEMP,NUM);
  1452.        MEDIAN:= DTEMP[NUM DIV 2];
  1453.      END;
  1454.  
  1455.    FUNCTION GETMAX(DATA:DATAARRAY;NUM:INTEGER):INTEGER;
  1456.  
  1457.      VAR
  1458.        T:INTEGER;
  1459.        MAX:REAL;
  1460.  
  1461.      BEGIN
  1462.        MAX:=DATA[1];
  1463.        FOR T:=2 TO NUM DO
  1464.          IF DATA[T] > MAX THEN MAX:= DATA[T];
  1465.        GETMAX := ROUND(MAX);
  1466.      END;
  1467.  
  1468.    FUNCTION GETMIN(DATA:DATAARRAY;NUM:INTEGER):INTEGER;
  1469.  
  1470.     VAR
  1471.       T:INTEGER;
  1472.       MIN:REAL;
  1473.  
  1474.     BEGIN
  1475.       MIN:= DATA[1];
  1476.       FOR T:=2 TO NUM DO
  1477.         IF DATA[T] < MIN THEN MIN:= DATA[T];
  1478.       GETMIN:= TRUNC(MIN);
  1479.     END;
  1480.  
  1481.   PROCEDURE TRANSFER;  {*** FOR GOING TO Q-CHART.EXE ***}
  1482.  
  1483.    VAR
  1484.        TRANSFER:FILE;
  1485.  
  1486.   BEGIN
  1487.     ASSIGN(TRANSFER,'EXEC.COM');
  1488.     EXECUTE(TRANSFER);
  1489.   END;
  1490.  
  1491.   BEGIN                                     { Main Code for Stats }
  1492.     SIGNON;
  1493.     FOR NUM:=1 TO 80 DO
  1494.       DATA[NUM]:=0;                 { Zero the array space }
  1495.     ENTERED := FALSE;
  1496.     DATANAME := '                     ';
  1497.     REPEAT
  1498.       CH:=UPCASE(MENU);
  1499.       CASE CH OF
  1500.         'E':ENTER(DATA);
  1501.         'D':TRANSFER;
  1502.         'B': BEGIN
  1503.                IF ENTERED THEN
  1504.                 BEGIN
  1505.                   CLRSCR;
  1506.                   DISPLAY(DATA,NUM);CLRSCR;
  1507.                   GOTOXY(10,2);
  1508.                   WRITELN('STATISTICS FOR: ',DATANAME);
  1509.                   GOTOXY(1,5);
  1510.                   TEXTCOLOR(7);
  1511.                   A:=MEAN(DATA,NUM);
  1512.                   M:=MEDIAN(DATA,NUM);
  1513.                   STD:=STDDEV(DATA,NUM);
  1514.                   WRITELN;
  1515.                   WRITELN('MEDIAN            :  ',M:10:2);
  1516.                   WRITELN;
  1517.                   WRITELN('MEAN              :  ',A:10:2);
  1518.                   WRITELN;
  1519.                   WRITELN('STANDARD DEVIATION:  ',STD:10:2);
  1520.                   WRITELN;
  1521.                   WRITELN('CV in %           :  ',((STD/A)*100):10:2);
  1522.                   WRITELN;
  1523.                   WRITELN
  1524.             ('MAXIMUM VALUE     :  ',GETMAX(DATA,NUM):10,'     Rounded (up)');
  1525.                   WRITELN;
  1526.                   WRITELN
  1527.         ('MINIMUM VALUE     :  ',GETMIN(DATA,NUM):10,'     Truncated (down)');
  1528.                   WRITELN;
  1529.                   WRITELN
  1530.  ('2 SD RANGE        :  ',(A-(2*STD)):10:2,'       TO ',(A+(2*STD)):10:2);
  1531.                   GOTOXY(1,23);
  1532.                   TEXTCOLOR(4);
  1533.                   WRITE('Peck any Key when done (or Shft-PrtSc to Print): ');
  1534.                   READ(KBD,CH);
  1535.                   CH := 'Q';
  1536.                 END
  1537.               ELSE
  1538.                 IF NOT ENTERED THEN
  1539.                   BEGIN
  1540.                     GOTOXY(5,20);
  1541.                     TEXTCOLOR(15);
  1542.                     WRITE('SORRY - NO VALUES, NO STATISTICS');
  1543.                     GOTOXY(1,23);
  1544.                     TEXTCOLOR(4);
  1545.                     WRITE('Peck any Key to continue: ');
  1546.                     READ(KBD,CH);
  1547.                     ENTERED :=FALSE;
  1548.                  END;
  1549.              END;
  1550.              END;
  1551.     UNTIL CH = 'Q';
  1552.   END;
  1553.  
  1554. {***************************** Moving Average Procedure ********************}
  1555.  
  1556.  
  1557. PROCEDURE MOVINGAV;
  1558.  
  1559.   CONST
  1560.     MAXNUMPERIOD=50;
  1561.  
  1562.   TYPE
  1563.     PERNUMTYPE=1..MAXNUMPERIOD;
  1564.     STRINGTYPE=STRING[80];
  1565.  
  1566.   VAR
  1567.     CH:CHAR;
  1568.     I,J,K,L:INTEGER;
  1569.     NUMAVERAGED,NUMPERIODS:INTEGER;
  1570.     PERIODVALUE:ARRAY [PERNUMTYPE] OF REAL;
  1571.     TRENDVALUE:REAL;
  1572.  
  1573.   PROCEDURE SIGNON;      { FIRST SCREEN }
  1574.  
  1575.     BEGIN
  1576.       GRAPHBACKGROUND(1);
  1577.       TEXTBACKGROUND(1);
  1578.       CLRSCR;
  1579.       GOTOXY(15,8);
  1580.       LOWVIDEO;
  1581.       FOR I:=1 TO 50 DO
  1582.         BEGIN
  1583.           WRITE(CHR(205))
  1584.         END;
  1585.       GOTOXY(20,10);
  1586.       HIGHVIDEO;
  1587.       TEXTBACKGROUND(1);
  1588.       TEXTCOLOR(4);
  1589.       WRITE('TREND ANALYSIS with MOVING AVERAGES');
  1590.       GOTOXY(15,12);
  1591.       LOWVIDEO;
  1592.         FOR J:= 1 TO 50 DO
  1593.           BEGIN
  1594.             WRITE(CHR(205))
  1595.           END;
  1596.       DELAY(3000);
  1597.       CLRSCR;
  1598.     END;
  1599.  
  1600.   PROCEDURE AVERAGINGPERIOD;         { GETS DATA }
  1601.  
  1602.     BEGIN
  1603.       REPEAT
  1604.         WRITELN;
  1605.         LOWVIDEO;
  1606.         TEXTBACKGROUND(1);
  1607.         WRITE('  Enter the number of periods to be averaged:  ');
  1608.         HIGHVIDEO;
  1609.         TEXTBACKGROUND(1);
  1610.         READLN(NUMAVERAGED);
  1611.            IF (NUMAVERAGED < 1) THEN
  1612.              BEGIN
  1613.                WRITELN;
  1614.                WRITE('HEY!!!! Are You TRYING To Make Me CRASH? ');
  1615.              END;
  1616.         WRITELN;
  1617.       UNTIL (NUMAVERAGED >= 1);
  1618.     END;
  1619.  
  1620.   PROCEDURE FACTSONLY;       { GETS MORE BIRDFOOD }
  1621.  
  1622.     VAR
  1623.       PERIODCOUNTER:PERNUMTYPE;
  1624.  
  1625.     BEGIN
  1626.       GRAPHBACKGROUND(1);
  1627.       TEXTBACKGROUND(1);
  1628.       CLRSCR;
  1629.       LOWVIDEO;
  1630.       TEXTBACKGROUND(1);
  1631.       TEXTCOLOR(0);
  1632.       WRITE('How many TIME PERIODS are to be pecked in? (50 Maximum):  ');
  1633.       HIGHVIDEO;
  1634.       TEXTBACKGROUND(1);
  1635.       READLN(NUMPERIODS);
  1636.         IF (NUMPERIODS > 50) THEN
  1637.           BEGIN
  1638.             WRITELN;
  1639.             TEXTCOLOR(4);
  1640.             WRITE('Hey! That''s more than 50.  Try again:  ');
  1641.             TEXTCOLOR(0);
  1642.             READLN(NUMPERIODS);
  1643.          END;
  1644.       WRITELN;
  1645.       LOWVIDEO;
  1646.       TEXTBACKGROUND(1);
  1647.       TEXTCOLOR(0);
  1648.       WRITELN('OK, enter a value for each of the ',NUMPERIODS,' periods: ');
  1649.       WRITELN;
  1650.         FOR PERIODCOUNTER:=1 TO NUMPERIODS DO
  1651.           BEGIN
  1652.             LOWVIDEO;
  1653.             TEXTBACKGROUND(1);
  1654.             WRITE('          ',PERIODCOUNTER:3,': ');
  1655.             HIGHVIDEO;
  1656.             TEXTBACKGROUND(1);
  1657.             READLN(PERIODVALUE[PERIODCOUNTER])
  1658.          END;
  1659.       SOUND(400);
  1660.       DELAY(400);
  1661.       NOSOUND;
  1662.       AVERAGINGPERIOD;                  { RUN PROCEDURE AVERAGINGPERIOD }
  1663.       WRITELN;
  1664.       WRITELN;
  1665.       WRITELN;
  1666.     END;
  1667.  
  1668.   PROCEDURE PATTERN1 (VAR F:TEXT);
  1669.  
  1670.     BEGIN
  1671.       TEXTBACKGROUND(1);
  1672.       LOWVIDEO;
  1673.       TEXTBACKGROUND(1);
  1674.       WRITE(F,' ');
  1675.         FOR L:=1 TO 70 DO
  1676.           BEGIN
  1677.             WRITE(F,CHR(205))
  1678.           END;
  1679.       HIGHVIDEO;
  1680.       TEXTBACKGROUND(1);
  1681.       WRITELN(F)
  1682.     END;
  1683.  
  1684.   PROCEDURE PATTERN2 (VAR F:TEXT);
  1685.  
  1686.     BEGIN
  1687.       TEXTBACKGROUND(1);
  1688.       LOWVIDEO;
  1689.       TEXTBACKGROUND(1);
  1690.       WRITE(F,'          ');
  1691.         FOR K:=1 TO 50 DO
  1692.           BEGIN
  1693.             WRITE(F,'-');
  1694.           END;
  1695.       HIGHVIDEO;
  1696.       TEXTBACKGROUND(1);
  1697.       WRITELN(F);
  1698.     END;
  1699.  
  1700.   PROCEDURE MAKETHETABLE (VAR F:TEXT);         { PRODUCE TIME TREND TABLE }
  1701.  
  1702.     VAR
  1703.       COUNTER:PERNUMTYPE;
  1704.       NUMSEQUENCE:INTEGER;
  1705.  
  1706.     BEGIN
  1707.       TEXTBACKGROUND(1);
  1708.       CLRSCR;
  1709.       LOWVIDEO;
  1710.       TEXTBACKGROUND(1);
  1711.       PATTERN1(F);
  1712.       WRITELN(F);
  1713.       HIGHVIDEO;
  1714.       TEXTBACKGROUND(1);
  1715.       WRITELN(F,'               MOVING AVERAGES - TIME TREND ANALYSIS');
  1716.       WRITELN(F);
  1717.       LOWVIDEO;
  1718.       TEXTBACKGROUND(1);
  1719.       PATTERN1(F);
  1720.       WRITELN(F);
  1721.       HIGHVIDEO;
  1722.       TEXTBACKGROUND(1);
  1723.       WRITE(F,'          ');
  1724.       WRITELN(F,'PERIOD          RAW DATA          SMOOTHED DATA');
  1725.       PATTERN2(F);
  1726.       WRITELN(F);
  1727.         FOR NUMSEQUENCE:=1 TO NUMPERIODS + 1 DO
  1728.           BEGIN
  1729.             TRENDVALUE:=0;
  1730.               IF (NUMSEQUENCE > NUMAVERAGED) THEN
  1731.                 BEGIN
  1732.                   FOR COUNTER:=1 TO NUMAVERAGED DO
  1733.                   TRENDVALUE:=TRENDVALUE + PERIODVALUE[NUMSEQUENCE-COUNTER];
  1734.                   TRENDVALUE:=TRENDVALUE/NUMAVERAGED;
  1735.                 END;
  1736.               IF (NUMSEQUENCE <= NUMPERIODS) THEN
  1737.                 BEGIN
  1738.                   WRITE(F,'          ',NUMSEQUENCE:7);
  1739.                   WRITE(F,'          ',PERIODVALUE[NUMSEQUENCE]:7:1);
  1740.                   WRITELN(F,'        ',TRENDVALUE:7:1)
  1741.                 END
  1742.               ELSE
  1743.                 BEGIN
  1744.                   WRITELN(F);
  1745.                   LOWVIDEO;
  1746.                   TEXTBACKGROUND(1);
  1747.                   PATTERN2(F);
  1748.                   HIGHVIDEO;
  1749.                   TEXTBACKGROUND(1);
  1750.                   WRITE(F,'          ','THE TREND FORCASTS PERIOD ');
  1751.                   WRITELN(F,NUMSEQUENCE,' AS: ',TRENDVALUE:7:1);
  1752.                   PATTERN2(F);
  1753.                   WRITE(F,'          ');
  1754.                   WRITELN(F,'NUMBER OF PERIODS AVERAGED:  ',NUMAVERAGED)
  1755.                 END
  1756.           END;
  1757.             WRITELN(F);
  1758.             PATTERN1(F);
  1759.     END;
  1760.  
  1761.   BEGIN                        { MAIN CODE }
  1762.  
  1763.     SIGNON;
  1764.     FACTSONLY;
  1765.     CLRSCR;
  1766.       REPEAT
  1767.         MAKETHETABLE(CON);
  1768.         WRITELN;
  1769.         LOWVIDEO;
  1770.         TEXTBACKGROUND(1);
  1771.         TEXTCOLOR(4);
  1772.         WRITE('  Repeat the Display?  (Y/N):  ');
  1773.         HIGHVIDEO;
  1774.         TEXTBACKGROUND(1);
  1775.         READ(KBD,CH);
  1776.           IF (CH='Y') OR (CH='y') THEN
  1777.             BEGIN
  1778.               WRITELN;
  1779.               LOWVIDEO;
  1780.               TEXTBACKGROUND(1);
  1781.               TEXTCOLOR(0);
  1782.               WRITE
  1783.               ('  Change the number of periods to be averaged?  (Y/N):  ');
  1784.               HIGHVIDEO;
  1785.               TEXTBACKGROUND(1);
  1786.               READ(KBD,CH);
  1787.                 IF (CH='Y') OR (CH='y') THEN
  1788.                   AVERAGINGPERIOD                 { GENERATE REVISED TABLE }
  1789.                 ELSE
  1790.                   MAKETHETABLE(CON)
  1791.             END
  1792.       UNTIL (CH='N') OR (CH='n');
  1793.         WRITELN;
  1794.         LOWVIDEO;
  1795.         TEXTBACKGROUND(1);
  1796.         TEXTCOLOR(16);
  1797.         WRITELN(' For a printout, turn on the printer.');
  1798.         TEXTCOLOR(0);
  1799.         WRITE(' When ready, peck the letter `Y'', or `N'' to QUIT:  ');
  1800.         HIGHVIDEO;
  1801.         TEXTBACKGROUND(1);
  1802.         READ(KBD,CH);
  1803.       WHILE (CH='Y') OR (CH='y') DO
  1804.         BEGIN
  1805.           WRITE(LST,(CHR(27)),(CHR(69)));
  1806.           MAKETHETABLE(LST);
  1807.           WRITE(LST,CHR(12));
  1808.           WRITELN;
  1809.           LOWVIDEO;
  1810.           TEXTBACKGROUND(1);
  1811.           WRITE(' Do another printout?  (Y/N):  ');
  1812.           READ(KBD,CH)
  1813.         END
  1814.   END;
  1815.  
  1816.  
  1817. {*************************** Employee Evaluation Procedure ******************}
  1818.  
  1819.     PROCEDURE eval;             { This is an Assignment/Execute Procedure   }
  1820.       VAR EVALUATE:FILE;        { To work, you must have compiled .COM      }
  1821.                                 { versions of LABCOAT.PAS and EVALUATE.PAS  }
  1822.                                 { together on the same disk.                }
  1823.       BEGIN
  1824.         ASSIGN(EVALUATE,'EVALUATE.COM');
  1825.         EXECUTE (evaluate);
  1826.       END;
  1827.  
  1828. {******************************** Escape from EVALUATE *********************}
  1829.  
  1830.    PROCEDURE EVALESCAPE;
  1831.  
  1832.       BEGIN
  1833.         TEXTBACKGROUND(1);
  1834.         CLRSCR;
  1835.         GOTOXY(20,10);
  1836.         TEXTCOLOR(15);
  1837.         WRITELN('EMPLOYEE EVALUATION PROGRAM');
  1838.         GOTOXY(15,13);
  1839.         TEXTCOLOR(4);
  1840.         WRITE('Peck `Y'' to continue or `N'' to return to Main Menu: ');
  1841.         READ(KBD,CH);
  1842.         IF CH = 'Y' THEN EVAL;
  1843.         IF CH = 'y' THEN EVAL;
  1844.       END;
  1845.  
  1846.  PROCEDURE LIPO;              { Calls Program LIPID via Execute }
  1847.  
  1848.   VAR
  1849.     LIPID:FILE;
  1850.  
  1851.     BEGIN
  1852.  
  1853.       ASSIGN(LIPID,'LIPID.COM');
  1854.       EXECUTE(LIPID);
  1855.  
  1856.     END;
  1857.  
  1858. procedure birdstuff;
  1859.  
  1860.  var birdface:file;
  1861.  begin
  1862.       assign (birdface,'birdface.com');
  1863.       execute(birdface);  end;
  1864.  
  1865. {############################# MAIN PROGRAM BODY ############################}
  1866.  
  1867.  
  1868. BEGIN
  1869.   SIGNON;
  1870.   EXPLAIN;
  1871.   MEM[$40:$17] := MEM[$40:$17] OR $40;     { toggles caps lock on }
  1872.   QUIT := FALSE;
  1873.     REPEAT
  1874.      TEXTBACKGROUND(2);
  1875.      GRAPHBACKGROUND(2);
  1876.      TEXTCOLOR(1);
  1877.      CLRSCR;
  1878.      GOTOXY(1,3);
  1879.      MAKEaLINE;
  1880.      GOTOXY(27,5);
  1881.      TEXTCOLOR(4);
  1882.      WRITE('**** MAIN USER MENU ****');
  1883.      GOTOXY(1,7);
  1884.      TEXTCOLOR(1);
  1885.      MAKEaLINE;
  1886.      GOTOXY(1,16);
  1887.      TEXTCOLOR(1);
  1888.      MAKEaLINE;
  1889.      GOTOXY(1,17);
  1890.      TEXTCOLOR(15);
  1891.      MAKEaLINE;
  1892.      GOTOXY(1,18);
  1893.      TEXTCOLOR(4);
  1894.      MAKEaLINE;
  1895.      GOTOXY(1,19);
  1896.      TEXTCOLOR(15);
  1897.      MAKEaLINE;
  1898.      GOTOXY(1,20);
  1899.      TEXTCOLOR(1);
  1900.      MAKEaLINE;
  1901.      GOTOXY(1,21);
  1902.      TEXTCOLOR(4);
  1903.      MAKEaLINE;
  1904.      GOTOXY(1,22);
  1905.      TEXTCOLOR(15);
  1906.      MAKEaLINE;
  1907.      GOTOXY(1,23);
  1908.      TEXTCOLOR(1);
  1909.      MAKEaLINE;
  1910.      GOTOXY(5,9);
  1911.      TEXTCOLOR(0);
  1912.      WRITE
  1913.   ('  [V] = Print Variables List             [T] = Enter Test Cost Data  ');
  1914.      WRITELN;
  1915.      GOTOXY(5,11);
  1916.      WRITE
  1917.    ('  [D] = Figure Depreciation              [S] = Mean , StanDev, Range');
  1918.      GOTOXY(5,13);
  1919.      WRITE
  1920.    ('  [M] = Moving Average Calculation       [E] = Employee evaluation ');
  1921.      GOTOXY(5,15);
  1922.      WRITE
  1923.    ('  [L] = Lipid Profile     [A] = Art      [Q] = QUIT  Peck Your Choice: ');
  1924.      READ(KBD,CH);
  1925.        CASE CH OF
  1926.          'V','v' : PRINTVAR;
  1927.          'T','t' : CHOOSE;
  1928.          'Q','q' : QUIT := TRUE;
  1929.          'D','d' : GETOUT;
  1930.          'S','s' : STATS;
  1931.          'L','l' : LIPO;       {!!!! Execute Procedure - See note Below!!!}
  1932.          'M','m' : MOVINGAV;
  1933.          'A','a' : BIRDSTUFF;  {!!! Go to Birdface Execute !!!}
  1934.          'E','e' : evalescape; {!!!!!!! Don't Use this Execute Procedure}
  1935.        END;                    {Unless compiling to a COM file!!!!!!!!!!}
  1936.     UNTIL QUIT;
  1937.     GRAPHBACKGROUND(0);TEXTBACKGROUND(0);TEXTCOLOR(7); { Reset Video to Exit }
  1938.     MEM[$40:$17] := MEM[$40:$17] AND $40;  { Reset Keyboard to Caps Lock Off }
  1939.     MEM[$40:$17] := MEM[$40:$17] AND $20;   { Reset Keyboard to Num Lock Off }
  1940.   CLRSCR
  1941.  
  1942. END.
  1943.  
  1944.  
  1945. {                                                                           }
  1946.  
  1947.